Business Shareware

home *** CD-ROM | disk | FTP | other *** search

/ Business Shareware / Business Shareware.iso / start / database / lib194 / screen.prg < prev next >

Wrap

Text File | 1993-02-05 | 53.8 KB | 1,350 lines

*------------------------------------------------------------------------------- *-- Program...: SCREEN.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 02/05/1993 *-- Notes.....: A few routines not left in PROC.PRG, these are not used as much *-- by my own systems. See the file: README.TXT for details on how *-- to use this library file. *------------------------------------------------------------------------------- FUNCTION Radio *------------------------------------------------------------------------------- *-- Programmer..: Ed Lafferty (CIS: 76150,3302) *-- Date........: 06/08/1992 *-- Notes.......: Routine to create and size a popup with radio buttons *-- for choosing only one of up to four options. Pressing *-- the <Space Bar> on an option turns it on or off. *-- Pressing <Enter> chooses the selected option and leaves *-- the routine. *-- Written for.: dBase IV, 1.1 *-- Rev. History: 02/25/1992 - original procedure. *-- 02/27/1992 -- Ken Mayer -- added option for color, but had *-- to take number of choices back to 4 to do so. Minor *-- alterations performed to add color choice ... and cleaning *-- up after self ... (original cleared the screen first ... *-- this version saves screen, restores back to it ...) Oh yeah, *-- I turned it into a function, rather than a procedure, as well. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: Radio(<nULRow>,<nULCol>,<nChoice>,"<cTxt1>","<cTxt2>",; *-- "<cTxt3>","<cTxt4>","<cTitle>","<cColor>") *-- Example.....: cPort = Radio(8,15,1,"LPT1","LPT2","LPT3","",; *-- "Choose a printer port","rg+/gb,n/w,rg+/gb") *-- Returns.....: number of chosen button in nChoice *-- Parameters..: nUlrow = upper left row of popup *-- nUlcol = upper left column of popup *-- nChoice = default chosen button *-- cTxt1 = Text for 1st button *-- cTxt2 = " " 2nd " *-- cTxt3 = " " 3rd " *-- cTxt4 = " " 4th " *-- cTitle = Text for the box title *-- cColor = Color string (i.e., "RG+/GB,N/W,RG+/GB") *------------------------------------------------------------------------------- parameters nUlrow, nUlcol, nChoice, cTxt1, cTxt2, cTxt3, cTxt4, ; cTitle, cColor private nHeight, nKey, nCnt, nWidth, cStr, cTxt0, cMidCol, cFirstCol,; cCursor cCursor = set("CURSOR") store cTitle to cTxt0 save screen to sRadio store 0 to nHeight, nKey, nCnt, nWidth store nChoice to nOrig && in case user presses <Esc> to exit ... *-- deal with these colors in displaying some stuff ... cMidCol = colorbrk(cColor,2) *-- First color (for message) is easier ... cFirstCol = colorbrk(cColor,1) *-- Determine height and width of popup do case case len(cTxt4) > 0 nHeight = 4 case len(cTxt3) > 0 nHeight = 3 case len(cTxt2) > 0 nHeight = 2 otherwise nHeight = 1 endcase do while nCnt <=nHeight store "cTxt"+str(nCnt,1) to cStr if len(&cstr) > nWidth nWidth = len(&cStr) endif nCnt = nCnt + 1 enddo *-- create popup define window wRadio from nUlRow,nUlCol to nUlRow+nHeight+3,nUlCol+nWidth+9; double color &cColor do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+; ", <Space> to select/de-select, <Enter> to quit" activate screen do shadow with nULRow, nULCol, nULRow+nHeight+3, nULCol+nWidth+9 activate window wRadio *-- display screen store 1 to nCnt do center with 0, nWidth+8, "", cTitle do while nCnt <= nHeight store "cTxt"+str(nCnt,1) to cStr @ nCnt+1, 2 SAY "[ ]" color &cMidCol @ nCnt+1, 6 say &cStr nCnt = nCnt + 1 enddo *-- prepare for and get nChoice if nChoice > 0 store nChoice to nCnt @nCnt+1,3 say "■" color &cMidCol else store 1 to nCnt endif store .F. to ldone *-- this loop processes user input ... do while .not. ldone @ nCnt+1,3 say "" color &cMidCol nkey = inkey(0) do case case nkey = 27 && Press Esc to exit store nOrig to nChoice && Leave at "default" store .T. to ldone case nkey = 13 store .T. to ldone case nkey = 32 && Press Enter or Space set cursor off if nChoice = nCnt @ nCnt+1,3 say " " color &cMidCol store 0 to nChoice else @ nChoice+1,3 say " " color &cMidCol @ nCnt+1,3 say "■" color &cMidCol store nCnt to nChoice endif set cursor on case nkey = 5 && Press up arrow if nCnt > 1 nCnt = nCnt - 1 else nCnt = nHeight endif case nkey = 24 && Press down arrow if nCnt < nHeight nCnt = nCnt + 1 else nCnt = 1 endif endcase enddo *-- cleanup deact window wRadio release window wRadio restore screen from sRadio release screen sRadio set message to set cursor &cCursor RETURN nChoice *-- EoF: Radio() PROCEDURE CheckBox *------------------------------------------------------------------------------- *-- Programmer..: Ed Lafferty (CIS: 76150,3302) *-- Date........: 02/28/1992 *-- Notes.......: Routine to create and size a popup with check boxes *-- for choosing any of a number (up to five) options. Pressing *-- the <Space Bar> on an option turns it on or off. *-- Pressing <Enter> chooses the selected option and leaves *-- the routine. You must use a data structure with logical *-- fields, or memvars that are logical for this. Either way, *-- even if you don't use five logical fields/memvars, you must *-- pass a field/memvar to the procedure -- see Example below *-- (the logicals -- lCHK1, lCHK2, etc.-- must be fields or *-- memvars due to a limitation in parameter passing in dBASE IV.) *-- Written for.: dBase IV, Version 1.1 *-- Rev. History: 02/25/1992 - original procedure. *-- 02/28/1992 -- Ken Mayer -- modified to allow passing cColor, *-- and a little cleanup of code and such. Minor changes. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: do checkbox with <nULCol>,<nULRow>,<lchk1>,<lchk2>,<lchk3>,; *-- <lchk4>,"<cTxt1>","<cTxt2>","<cTxt2>",; *-- "<cTxt3>","<cTxt4>","<cTxt0>","<cColor>" *-- Example.....: do Checkbox with 8, 15, lchk1, lchk2, lchk3, lchk4,; *-- "LPT1", "LPT2", "LPT3","","Choose a printer port",; *-- "rg+/gb,w+/n,rg+/gb" *-- Returns.....: .T. for selected items, .F. for non-selected items -- *-- this routine changes the value of the logical fields passed *-- to it. *-- Parameters..: nULRow = upper left row of popup *-- nULCol = upper left column of popup *-- lChkn = default value of box 'n' -- MUST BE FIELDS/MEMVARS *-- cTxt1 = Text for 1st box *-- cTxt2 = " " 2nd " *-- cTxt3 = " " 3rd " *-- cTxt4 = " " 4th " *-- cTxt0 = Text for the box title *-- cColor = Colors to be used in window ... *------------------------------------------------------------------------------- parameters nUlrow, nUlcol, lChk1, lChk2, lChk3, lChk4, ; cTxt1, cTxt2, cTxt3, cTxt4, cTxt0, cColor private nHeight, nKey, nCnt, nWidth, lOrig1, lOrig2, lOrig3, lOrig4,; cMidCol, cFirstCol, cCursor *-- setup ... cCursor = set("CURSOR") save screen to sCheck store 0 to nHeight, nKey, nCnt, nWidth *-- save original settings, in case <Esc> gets pressed below ... store lChk1 to lOrig1 store lChk2 to lOrig2 store lChk3 to lOrig3 store lChk4 to lOrig4 *-- deal with some colors ... cMidCol = colorbrk(cColor,2) cFirstCol = colorbrk(cColor,1) *-- Determine height and width of popup *-- Determine height do case case len(cTxt4) > 0 nHeight = 4 case len(cTxt3) > 0 nHeight = 3 case len(cTxt2) > 0 nHeight = 2 case len(cTxt1) > 0 nHeight = 1 endcase *-- Determine width do while nCnt <=nHeight store "cTxt"+str(nCnt,1) to cStr if len(&cstr) > nWidth nWidth = len(&cStr) endif nCnt = nCnt + 1 enddo *-- create popup define window wCheck from nUlrow, nUlcol to nUlrow+nHeight+3, nUlcol+nWidth+8; double color &cColor do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+; ", <Space> to select/de-select, <Enter> to quit" activate screen do shadow with nULRow,nULCol,nULRow+nHeight+3,nULCol+nWidth+8 activate window wCheck store 1 to nCnt do center with 0, nWidth+8, "", cTxt0 *-- paint screen do while nCnt <= nHeight store "cTxt"+str(nCnt,1) to cStr store "lChk"+str(nCnt,1) to cChk @ nCnt+1, 2 SAY "[ ]" color &cMidCol @ nCnt+1, 6 say &cStr @ nCnt+1, 3 SAY IIF(&cChk,"X"," ") color &cMidCol nCnt = nCnt + 1 enddo *-- prepare for and get nChoice store 1 to nCnt store .F. to ldone do while .not. ldone store "lChk"+str(nCnt,1) to cChk @ nCnt+1,3 say "" color &cMidCol nkey = inkey(0) do case case nkey = 27 && Press Esc to exit store lorig1 to lChk1 && Therefore, restore original store lOrig2 to lChk2 && values to lChk<n>'s store lOrig3 to lChk3 store lOrig4 to lChk4 store .T. to ldone case nkey = 13 && Press Enter when finished store .T. to ldone case nkey = 32 && Press Space set cursor off if &cChk && Box was already selected, @ nCnt+1,3 say " " color &cMidCol && so now de-select it store .F. to &cChk else && Box was not already selected, @ nCnt+1,3 say "X" color &cMidCol && so now select it store .T. to &cChk endif set cursor on case nkey = 5 && Press up arrow if nCnt > 1 nCnt = nCnt - 1 else nCnt = nHeight endif case nkey = 24 && Press down arrow if nCnt < nHeight nCnt = nCnt + 1 else nCnt = 1 endif endcase enddo *-- Cleanup release window wCheck restore screen from sCheck release screen sCheck set message to set cursor &cCursor RETURN *-- EoP: ChkBox FUNCTION MenuPad *------------------------------------------------------------------------------- *-- Programmer..: Douglas P. Saine (CIS: 74660,3574) *-- Date........: 02/11/1992 *-- Notes.......: Used to create menu prompts of an even length. It works *-- on any prompt - menu pads or popups. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 02/07/1992 - original function. *-- 02/11/1992 -- Ken Mayer -- modified to truncate <cChoice> *-- if it's longer than <nLength>. *-- Calls.......: ALLTRIM() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: MenuPad("<cChoice>",<nLength>) *-- Example.....: Define pad pPad1 of mMain; *-- prompt MenuPad("Menu Choice1",25) at 2,5 *-- Returns.....: <cChoice> padded with spaces (or truncated, if necessary) *-- to <nLength>. *-- Parameters..: cChoice = Menu-Pad/Popup-Bar Prompt description *-- nLength = Length of pad/bar ... *------------------------------------------------------------------------------- parameters cChoice, nLength private cReturn if len(alltrim(cChoice)) > nLength && is it too long? cReturn = left(cChoice,nLength) && truncate it ... else && otherwise, pad it with spaces to the length required cReturn = cChoice + space(nLength-len(alltrim(cChoice))) endif RETURN cReturn *-- EoF: MenuPad() FUNCTION Banner *------------------------------------------------------------------------------- *-- Programmer..: Dan Madoni (Borland) *-- Date........: 09/xx/1991 *-- Notes.......: This will display a left-scrolling message on the screen *-- within the boundaries specified in the UDF by the user. *-- It will wait for a keypress and then go away. Taken from *-- TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Usage.......: Banner(<nRow>,<nCol>,<nWidth>,"<cMessage>","<cColor>") *-- Example.....: ?? Banner(5,30,20,"Love your tie, is it new?","w+/r") *-- Returns.....: Null ("") *-- Parameters..: nRow = Leftmost ROW position of scrolled message *-- nCol = Leftmost COL position of scrolled message *-- nWidth = Length of displayable area starting at nRow,nCol *-- cMessage = Message to be scrolled *-- cColor = Color of scrolling message *------------------------------------------------------------------------------- parameters nRow,nCol,nWidth,cMessage,cColor private cCursor,cTalk,cMsg,nCounter,cPause *-- save some environment essentials save screen to sBanner cCursor = set("CURSOR") cTalk = set("TALK") set cursor off set talk off *-- deal with message cMsg = space(nWidth)+cMessage+" " nCounter = 0 *-- loop do while .t. nCounter = nCounter + 1 if nCounter > len(cMsg) nCounter = 1 endif *-- user hits any key cPause = inkey(.15) if cPause # 0 exit endif *-- display message within scrollable area @nRow,nCol say substr(cMsg,nCounter,nWidth) color &cColor enddo *-- restore environment restore screen from sBanner release screen sBanner set cursor &cCursor set talk &cTalk RETURN "" *-- EoF: Banner() FUNCTION SeeMatch *------------------------------------------------------------------------------- *-- Programmer..: Dan Madoni (Borland) *-- Date........: 09/xx/1991 *-- Notes.......: Can be included in format screen to display an instant *-- lookup match on a particular field. A shadowed box will *-- appear with the matching value ... Taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 06/12/1992 -- Minor -- added call to RECOLOR *-- Calls.......: RECOLOR Procedure in PROC.PRG *-- Called by...: None *-- Usage.......: SeeMatch("<cFile>",<cSeekExp>,"<cReturn>",<nULRow>,<nULCol>,; *-- <nBRRow>,<nBRCol>,"<cColor>) *-- Example.....: SeeMatch("TRAVEL",LASTNAME,"TRAVELCODE",2,40,4,60,"w+/r") *-- Returns.....: .t. *-- Parameters..: cFile = Database alias in which lookup will be performed. *-- -- this file must already be USEd in some area. *-- cSeekExp = Expression which will be SEEKed. *-- cReturn = Name of field to contain the 'return' value. *-- nULRow = Upper Left Row for box *-- nULCol = Upper Left Column for box *-- nBRRow = Bottom Right Row *-- nBRCol = Bottom Right Column *-- cColor = Color of box *------------------------------------------------------------------------------- parameters cFile,cSeeExp,cReturn,nULRow,nULCol,nBRRow,nBRCol,cColor private cRetVal, cAttr, cStartFile *-- store starting position ... cStartFile = alias() select &cFile *-- look for a matching expression seek cSeekExp if found() cRetVal = &cReturn else cRetVal = "<Not Found>" endif *-- Store current color and draw a box cAttr = set("ATTRIBUTES") @nULRow+1,nULCol+1 fill to nBRRow+1,nBRCol+1 color w/n && shadow set color to &cColor @nULRow,nULCol clear to nBRRow,nBRCol && clear out area text will go in @nULRow,nULCol To nBRRow,nBRCol && draw box *-- display matching expresion, and return to initial area ... @nULRow+1,nULCol+2 say cRetVal do ReColor with cAttr select cStartFile RETURN .t. *-- EoF: SeeMatch() FUNCTION Dialog *------------------------------------------------------------------------------- *-- Programmer..: Larry Quaglia (Borland) *-- Date........: 11/xx/1991 *-- Notes.......: This routine provides a 'standard' set of dialogue boxes *-- and buttons for all applications. The concept is to provide *-- standardization for your apps. Taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 11/xx/1991 -- first published in TechNotes. *-- 06/09/1992 -- Modified to handle explicit colors, changed *-- the color parameters a tad ... (Ken Mayer) *-- Calls.......: SHADOW Function in PROC.PRG *-- RECOLOR Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: Dialog("<cMsg>",<nType>,"<cBorder>",<nDefBut>,<lShadow>,; *-- "<cWind>","<cButton>") *-- Example.....: Dialog("We have completed the transaction.",0,"DOUBLE",; *-- 0,.t.,"RG+/GB","W+/N") *-- Returns.....: Character -- Either 'ERROR' or title of Button. *-- Parameters..: cMsg = Message to be displayed -- maximum of 78 characters *-- (one line only) *-- nType = Dialogue box TYPE. Options are 0 to 5: *-- 0: 'OK' *-- 1: 'OK' 'CANCEL' *-- 2: 'ABORT' 'RETRY' 'IGNORE' *-- 3: 'YES' 'NO' 'CANCEL' *-- 4: 'YES' 'NO' *-- 5: 'RETRY' 'CANCEL' *-- cBorder = Border Style -- options are: "" (null) for SINGLE *-- DOUBLE or PANEL. *-- nDefBut = Default Button. *-- lShadow = Display with a shadow or not (both on window and *-- buttons)? *-- cWind = Window Colors (must be valid dBASE color combo: *-- i.e., "RG+/GB") *-- cButton = Highlighted Button Color (Same as above, should *-- contrast ...) *------------------------------------------------------------------------------- parameters cMsg,nType,cBorder,nDefBut,lShadow,cWind,cButton private nMsgLen,cNewColor,aButton,nMaxLine,nY,nBoxLen,nNumButton,nCounter,; nBasex,nYCol,nMsgLoc,cCurColor save screen to sDialog && so we can restore at end of routine *-- determine length of message nMsgLen = len(trim(ltrim(cMsg))) + 1 *-- Check for valid parms do case case nMsgLen > 78 RETURN "ERROR - Message Length" case .not. (upper(cBorder) = "DOUBLE" .or. upper(cBorder) = "PANEL" .or.; len(trim(cBorder)) = 0) RETURN "ERROR - Border" endcase *-- save current color info and set color to user-defined cCurColor = set("ATTRIBUTES") set color of normal to &cWind set color of box to &cWind set color of message to &cWind set color of highlight to &cButton *-- Allow use of <Tab> to move from button to button on key label tab keyboard chr(4) && act as if right arrow were pushed *-- Define button array -- max of 3 buttons (at the moment) declare aButton[3] aButton[1] = "" aButton[2] = "" aButton[3] = "" *-- Establish screen height to properly center dialogue box nMaxLine = iif(right(set("DISP"),2) = "43",43,24) *-- Determine length of passed "message" parameter. If long enough, make *-- the dialog box a little bigger. If very short, make it just big *-- enough to accomodate the three buttons. nY = iif(int(nMsgLen) > 30,int(nMsgLen/2)+2,24) nBoxLen = 2 * nY *-- Setup the window and determine if shadow ... if yes, call shadow define window wDialog from int(nMaxLine/2)-5,40-nY to ; int(nMaxLine/2)+4,40+nY &cBorder if lShadow activate screen do shadow with int(nMaxLine/2)-5,40-nY,int(nMaxLine/2)+4,40+nY endif activate window wDialog clear *-- Determine the type of buttons and set appropriate parms. *-- These could be modified to your own needs. do case case nType = 0 nNumButton = 1 aButton[1] = " OK " case nType = 1 nNumButton = 2 aButton[1] = " OK " aButton[2] = " CANCEL " case nType = 2 nNumButton = 3 aButton[1] = " ABORT " aButton[2] = " RETRY " aButton[3] = " IGNORE " case nType = 3 nNumButton = 3 aButton[1] = " YES " aButton[2] = " NO " aButton[3] = " CANCEL " case nType = 4 nNumButton = 2 aButton[1] = " YES " aButton[2] = " NO " case nType = 5 nNumButton = 2 aButton[1] = " RETRY " aButton[2] = " CANCEL " endcase *-- Get dialog box length to create a bar menu of appropriate size. *-- Define the bar menu in a loop. Deactivate it upon selection of *-- one of the buttons. nCounter = 1 nBaseX = nBoxLen / (nNumButton + 1) define menu mDialog do while nCounter <= nNumButton pPadName = "PAD"+str(nCounter,1) && pad name is 'PAD #' nYCol = (nCounter * nBaseX) - (int(len(aButton[nCounter]) /2)) define pad &pPadName of mDialog prompt aButton[nCounter] at 4,nYCol *-- If shadow is on, put shadows on buttons as well ... if lShadow activate screen do shadow with 3,nYCol-2,5,nYCol+(len(aButton[nCounter]))-1 endif @3,nYCol-1 to 5,nYCol+(len(aButton[nCounter])) && box around button on selection pad &pPadName of mDialog deactivate menu nCounter = nCounter + 1 enddo *-- place message (centered in box) nMsgLoc = int(nBoxLen/2) - int(nMsgLen/2) @1,nMsgLoc say cMsg *-- place cursor to the default button specified by the user nCounter = 1 do while nCounter < nDefBut keyboard chr(4) nCounter = nCounter + 1 enddo *-- Activate the whole thing, and return the button name activate menu mDialog cValue = trim(ltrim(prompt())) *-- deactivate it all, restore screen, etc. deactivate window wDialog release window wDialog release menu mDialog restore screen from sDialog release screen sDialog do ReColor with cCurColor on key label tab RETURN cValue *-- EoF: Dialog() FUNCTION MsgExp *------------------------------------------------------------------------------- *-- Programmer..: Adam Menkes (Borland) *-- Date........: 02/05/1993 *-- Notes.......: Allows you to display message (or error message), centered *-- like SET MESSAGE ... with added utility. Does not use *-- "(Press Space)", which can be annoying. The message and the *-- line on which it is displayed will be the same color. *-- Taken from TECHNOTES. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 09/xx/1991 -- Original routine *-- 02/05/1993 -- Modified by Lee Hite to handle a string that *-- is greater than 80 characters (this can be *-- a real problem if the message is in row 24!) *-- Usage.......: MsgExp("<cExp>") *-- Example.....: MsgExp("This is a message") *-- Returns.....: Message displayed (centered) on screen *-- Parameters..: cExp = Message to be displayed *------------------------------------------------------------------------------- parameters cMsg private nLen nLen = (80-len(trim(cMsg)))/2 RETURN space(nLen) + trim(cMsg) + space(nLen+0.5) *-- EoF: MsgExp FUNCTION YesNoCan *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 02/01/1993 *-- Notes.......: Asks a yes/no/cancel question in a dialog window/box *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function *-- 04/29/1991 - Modified to Ken Mayer add shadow *-- 05/13/1991 - Modified to Ken Mayer remove need for extra *-- procedures (YES/NO) that were used for returning *-- values from Menu *-- (suggested by Clinton L. Warren (VBCES)) *-- 01/20/1992 - Modified by Martin Leon (HMan) to handle user *-- pressing 'Y' or 'N' keys (with ON KEY ...). *-- 06/11/1992 - Modified by Joey Carroll (JOEY) to allow *-- answer choices to be "Yes", "No", or "Cancel" *-- or to allow for parameters to pass the contents *-- of the prompts. If none are passed, they default *-- to "Yes", "No", "Cancel". Further modified to *-- allow specification of location by row if *-- desired. Window size now varies as parameters *-- dictate. *-- 09/21/1992 - Modified by JOEY to fix bug caused if leading *-- blanks in parameters cPrompt1,cPrompt2,cPrompt3 *-- Corrected example - case pad()="PPAD1" *-- instead of case pad()=PPAD1 *-- 02/01/1993 - Mods by Lee Hite: Routine would not wait for *-- user response if "default" answer did not match *-- one of the prompts. Now first prompt becomes *-- default if no match is found on invocation. *-- Also, match is no longer case sensitive. Also *-- made window height variable if message *-- lines 2 and/or 3 are null strings. Finally, *-- added "confirmation" parameter which when set *-- true will force user to press [Enter] before *-- function returns. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- ISBLANK() Function in MISC.PRG, Internal in 1.5 *-- Called by...: Any *-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",; *-- "<cPrompt1>","<cPrompt2>","<cPrompt3>",; *-- <nTopRow>,"<cColor>",[lConfirm]) *-- Example.....: cAnswer="Y" *-- cAnswer=YesNoCan(cAnswer,"*** Warning ***",; *-- "A serious error has occured.",; *-- "Choose carefully.","Proceed",; *-- "Retry","Cancel",10,; *-- "w+/r,n/w,w+/r") *-- do case *-- case cAnswer="Y" && OR case pad()="PPAD1" *-- * do your thing *-- case cAnswer="N" && OR case pad()="PPAD2" *-- skip *-- case cAnswer="C" && OR case pad()="PPAD3" *-- * e.g. - return *-- endcase *-- *-- The middle set of colors should be different, as they *-- will be the colors of the YES/NO selections ... *-- Options may be blank by using nul values ("") *-- Returns.....: First character of selected pad *-- Parameters..: cAnswer = default value (Yes or No or Cancel) for menu *-- cMess1 = First line of Message *-- cMess2 = Second line of message *-- cMess3 = Third line of message *-- cPrompt1 = Optional prompt for left pad *-- cPrompt2 = Optional prompt for middle pad *-- cPrompt3 = Optional prompt for right pad *-- nTopRow = Optional top row of window *-- cColor = Optional colors for window/menu/box *-- lConfirm = Optional "confirmation" parameter -- if true *-- user must press [Enter], otherwise pressing *-- a valid prompt key automatically returns *------------------------------------------------------------------------------- parameter cAnswer,cMess1,cMess2,cMess3,; cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth, ; cConfirm, nWinHgth, nMsgRow private cPrompt1,cPrompt2,cPrompt3 *-- save screen so we can restore ... save screen to sYesNoCan * locate top row of window nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line nTopRow = iif(isblank(nTopRow),14,nTopRow) && no parameter passed nTopRow = min(nTopRowMax,nTopRow) * set pad prompts if none passed cPrompt1 = iif(isblank(cPrompt1),"Yes",cPrompt1) cPrompt2 = iif(isblank(cPrompt2),"No",cPrompt2) cPrompt3 = iif(isblank(cPrompt3),"Cancel",cPrompt3) cAnswer = iif(isblank(cAnswer),cPrompt1,cAnswer) * program bombs if prompts passed contain leading blanks cPrompt1 = ltrim(trim(cPrompt1)) cPrompt2 = ltrim(trim(cPrompt2)) cPrompt3 = ltrim(trim(cPrompt3)) * determine how wide the window needs to be nWinWidth = max(19,len(cPrompt1 + cPrompt2 + cPrompt3) +13) nWinWidth = max(nWinWidth,len(cMess1)+4) nWinWidth = max(nWinWidth,len(cMess2)+4) nWinWidth = max(nWinWidth,len(cMess3)+4) * and how high it needs to be nWinHgth = iif(""=cMess2,7,8) nWinHgth = iif(""=cMess3,nWinHgth-1,nWinHgth) * and center it define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ; to nTopRow+nWinHgth-1,40+(nWinWidth+2)/2 double color &cColor. define menu mYesNoCan define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ; at nWinHgth-3,02 * center middle prompt between other two, not center of window define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]" at nWinHgth-3, ; ((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2) define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]" ; at nWinHgth-3,(nWinWidth-3)-(len(cPrompt3)) on selection pad pPad1 of mYesNoCan deactivate menu on selection pad pPad2 of mYesNoCan deactivate menu on selection pad pPad3 of mYesNoCan deactivate menu activate screen do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+nWinHgth-1, ; 40+(nWinWidth+2)/2 activate window wYesNoCan do center with 0,nWinWidth,"",cMess1 && center the text *-- deal with blank message lines nMsgRow = 2 if "" <> cMess2 do center with nMsgRow,nWinWidth,"",cMess2 nMsgRow = nMsgRow + 1 endif if "" <> cMess3 do center with nMsgRow,nWinWidth,"",cMess3 endif *-- deal with user pressing first key of prompt cKey1 = left(cPrompt1,1) cKey2 = left(cPrompt2,1) cKey3 = left(cPrompt3,1) *-- set [CR] at end of keyboard command depending on "confirm" parameter cConfirm = iif(lConfirm,"",chr(13)) on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ; iif(pad() = "PPAD2", chr(19),CHR(4) )) + cConfirm on key label &cKey2. keyboard iif( PAD() = "PPAD2", "", ; iif(pad() = "PPAD1",CHR(4),chr(19) )) + cConfirm on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ; iif(pad() = "PPAD2", CHR(4),chr(19))) + cConfirm clear typeahead *-- otherwise deal with regular "menu" abilities do case case upper(cAnswer)=upper(cKey1) activate menu mYesNoCan pad pPad1 case upper(cAnswer)=upper(cKey2) activate menu mYesNoCan pad pPad2 case upper(cAnswer)=upper(cKey3) activate menu mYesNoCan pad pPad3 otherwise activate menu mYesNoCan pad pPad1 endcase *-- clear out ON KEY settings ... on key label &cKey1. on key label &cKey2. on key label &cKey3. *-- reset environment deactivate window wYesNoCan release window wYesNoCan restore screen from sYesNoCan release screen sYesNoCan release menu mYesNoCan RETURN upper(substr(prompt(),2,1)) *-- EoF: YesNoCan() PROCEDURE ProgBar2 *------------------------------------------------------------------------------- *-- Programmer..: Joey D. Carroll (JOEY) *-- Date........: 06/28/1992 *-- Notes.......: A crippled version of PROGBAR for those who want it simple. *-- A visual indicator of program activity, i.e. shows *-- user program didn't die during long processes which *-- do not normally show 'on screen'. Serves same purpose *-- as MONITOR, but is more graphic. *-- For best appearance, set cursor 'off' from calling *-- program, outside of the loop which calls PROGBAR. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 10/26/1992 -- protected existing active window. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PROGBAR2 with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2> *-- Example.....: *-- determine what process will be monitored and what the *-- *-- final value will be, e.g. nReccount = reccount() *-- use <anyfile> *-- nReccount = reccount() *-- set cursor off *-- scan *-- do progbar2 with nReccount,",,w+/n","w+/r","w+/g" *-- *-- do some needed process here *-- endscan *-- *-- cleanup *-- Returns.....: None *-- Parameters..: nQuan = maximum number of iterations *-- cWindCol = the window colors *-- cFillCol1 = color of ruler before process *-- cFillCol2 = color of ruler after process *------------------------------------------------------------------------------- parameters nQuan,cWindCol,cFillCol1,cFillCol2 && e.g. how many records private nWindWidth nWindWidth = 78 && hard coded, wall to wall *-- skip this section if we've been here before *-- this procedure called from inside a loop *-- following section ignored except on first iteration thru loop if type("nTimes") = "U" save screen to sProgBar public nFactor,nTimes,wPrevWind wPrevWind = window() if set("status") = "ON" && different location if status "on" define window wProgBar from 19,0 to 21,79 double color &cWindCol else define window wProgBar from 21,0 to 23,79 double color &cWindCol endif && set("status") = "ON" activate window wProgBar @ 0,0 say replicate(".",nWindWidth - 1) && the ruler @ 0,0 say "0%" && and some gradation %'s @ 0,nWindWidth / 4 - 2 say "25%" @ 0,nWindWidth / 2 - 2 say "50%" @ 0,3*(nWindWidth / 4) - 2 say "75%" @ 0,nWindWidth - 4 say "100%" @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1 && color of ruler before process nFactor = nQuan/nWindWidth && e.g. how many records per bar part(cols) nTimes = 0 && times thru loop endif && type("nTimes") = "U" *-- the section will be processed as many times as required by nQuan nTimes = nTimes+1 @ 0,0 fill to 0,int(nTimes/nFactor) ; - iif(int(nTimes/nFactor) -1 >= 0,1,0) ; color &cFillCol2 && color of ruler as processing takes place if nTimes = nQuan && we done x = inkey(.5) && leave on screen just a liitle while after completion * cleanup your mess deactivate window wProgBar release window wProgBar restore screen from sProgBar release screen sProgBar *-- if window was active, re-activate if .not. isblank(wPrevWind) activate window wPrevWind endif release nProgBar,nFactor,nTimes,nWindWidth,x,wPrevWind endif RETURN *-- EoP: PROGBAR2 PROCEDURE MovePad *------------------------------------------------------------------------------- *-- Programmer..: Angus Scott-Fleming (CIS: 65500,3223) *-- Date........: 07/24/1992 *-- Notes.......: Used to move the selected pad in a dBASE Bar Menu if the user *-- selects the first letter/key of the pad. The routine doesn't *-- re-evalute PAD(), and is based on Genifer code (improved on *-- by Angus). This should be used with the ON KEY command. *-- NOTE: This routine assumes you are using the dUFLP/dHUNG *-- standard for naming pads, and that the first character of *-- each pad NAME is 'p' (i.e., pColor, pExit, etc.). *-- Written for.: dBASE IV, 1.5, should work in 1.1. *-- Rev. History: 07/29/1992 -- Added header/notes. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do MovePad with <cLetter>,<lSelect>,<cChoices> *-- Example.....: on key label "C" do MovePad with "C",.t.,cChoices *-- Returns.....: None *-- Parameters..: cLetter = first letter/key on pad *-- lSelect = select pad, or move cursor to it? (Act as if user *-- pressed <Enter> after moving to it?) *-- cChoices = list of possible choices (i.e., *-- "Enter,Edit,Delete,Print,Exit") *------------------------------------------------------------------------------- parameters cLetter, lSelect, cChoices private nToMove *-- determine how many pads to move, based on position of choice in list *-- of choices (cChoices). nToMove = at(cLetter,cChoices) - at(substr(pad(),2,1),cChoices) *-- if it is a negative value, move to the left, and press <Enter> if *-- lSelect = .t. (otherwise, just move there and stop). if nToMove < 0 keyboard replicate(chr(5), -nToMove) + iif(lSelect,chr(13),"") else keyboard replicate(chr(24), nToMove) + iif(lSelect,chr(13),"") endif RETURN *-- EoP: MovePad PROCEDURE Monitor *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 06/08/1992 *-- Notes.......: Displays a status message to monitor a long-running *-- operation that operates on multiple records . . . *-- Should be used with MONITOROFF (below) to cleanup. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/29/1991 - Modified by Ken Mayer to add shadow *-- 06/08/1992 - Modified to handle explicit color setting *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: do monitor with "<cText>","<cColor>" *-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb" *-- nRec = 0 *-- do while && (or SCAN) *-- && stuff -- process records *-- nRec = nRec + 1 *-- @4,30 display ltrim(str(nRec)) && current record *-- && in window MONITOR *-- enddo && (or endscan) *-- do MonitorOff && procedure to clean-up after this one *-- Returns.....: None *-- Parameters..: cText = Text to display *-- cColor = Colors for window *------------------------------------------------------------------------------- parameters cText,cColor private cTempCol save screen to sMonitor activate screen define window wMonitor From 10,10 to 18,70 double color &cColor do shadow with 10,10,18,70 activate window wMonitor do center with 1,60,"",cText do center with 2,60,"","Please do not interrupt" @4,10 say "Working on record of " + ltrim(str(reccount(),5)) RETURN *-- EoP: Monitor PROCEDURE MonitorOff *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/23/1991 *-- Notes.......: Used to deal with ending routines for MONITOR *-- procedure above. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Routine using MONITOR Procedure in PROC.PRG *-- Usage.......: do monitoroff *-- Example.....: do monitoroff *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- deactivate window wMonitor release window wMonitor restore screen from sMonitor release screen sMonitor RETURN *-- EoP: MonitorOff FUNCTION NewBorder *------------------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 01/20/1993 *-- Notes.......: Will save current border setting (the returned value), *-- and set a new one with one of a set of pre-defined *-- borders. This will create a new variable if it doesn't *-- already exist, called: c_Border, which is a PUBLIC Character *-- variable. The purpose is so that you can keep using this *-- string for other purpose (i.e., DEFINE WINDOW and such ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: NewBorder("<cStyle>") *-- Example.....: cOldBorder = NewBorder("K") *-- @5,10 to 15,60 && draw box with new "border" setting *-- *-- define a window with new "border" setting *-- define window wTest from 10,20 to 20,60 &c_Border *-- set border to &cOldBorder && reset border to original *-- Returns.....: Current border setting (before calling routine) *-- Parameters..: cStyle = Style from one of the following: *-- A = Double *-- ╔════╗ *-- ║ ║ *-- ╚════╝ *-- B = Single *-- ┌────┐ *-- │ │ *-- └────┘ *-- C = Panel *-- ██████ *-- █ █ *-- ██████ *-- D = None *-- E = Double Top, Single Left, Right, and Bottom *-- ╒════╕ *-- │ │ *-- └────┘ *-- F = Single Top, Double Left, Right and Bottom *-- ╓────╖ *-- ║ ║ *-- ╚════╝ *-- G = Double Top, Left, Right, Single Bottom *-- ╔════╗ *-- ║ ║ *-- ╙────╜ *-- H = Single Top, Left, Right, Double Bottom *-- ┌────┐ *-- │ │ *-- ╘════╛ *-- I = Double Top, Single Left and Right, Double Bottom *-- ╒════╕ *-- │ │ *-- ╘════╛ *-- J = Single Top, Double Left and Right, Single Bottom *-- ╓────╖ *-- ║ ║ *-- ╙────╜ *-- K = Single Top and Left, Double Right and Bottom *-- ┌────╖ *-- │ ║ *-- ╘════╝ *-- L = Single Top, Double Left, Single Right, Dbl Bottom *-- ╓────┐ *-- ║ │ *-- ╚════╛ *-- M = Double Top and Left, Single Right and Bottom *-- ╔════╕ *-- ║ │ *-- ╙────┘ *-- N = Double Top, Single Left, Double Right, Sgl Bottom *-- ╒════╗ *-- │ ║ *-- └────╜ *-- O = Double Top, Single Left, Double Right and Bottom *-- ╒════╗ *-- │ ║ *-- ╘════╝ *-- P = Double Top, Left, Single Right, Double Bottom *-- ╔═════╕ *-- ║ │ *-- ╚═════╛ *-- Q = Single Top, Double Left, Single Right and Bottom *-- ╓─────┐ *-- ║ │ *-- ╙─────┘ *-- R = Single Top and Left, Double Right, Single Bottom *-- ┌─────╖ *-- │ ║ *-- └─────╜ *-- S = Panel, but with more room on the interior ... *-- the default 'panel' mode for borders uses *-- ASCII 219 (alla way around), where this *-- uses 220-223 ... *-- ▐▀▀▀▀▀▌ *-- ▐ ▌ *-- ▐▄▄▄▄▄▌ *------------------------------------------------------------------------------- parameters cStyle cReturn = set("BORDER") && current border -- if version of dBASE is && less than 1.5, comment this out ... if type("c_Border") = "U" && if this is undefined public c_Border && declare it as public endif *-- here we go ... do case case cStyle = "A" c_Border = "DOUBLE" && pre-defined case cStyle = "B" c_Border = "SINGLE" && pre-defined case cStyle = "C" c_Border = "PANEL" && pre-defined case cStyle = "D" c_Border = "NONE" && pre-defined case cStyle = "E" *-- items are: top line, bottom line, left line, right line, *-- upper left corner, upper right corner, bottom left corner, *-- bottom right corner c_Border = "205,196,179,179,213,184,192,217" case cStyle = "F" c_Border = "196,205,186,186,214,183,200,188" case cStyle = "G" c_Border = "205,196,186,186,201,187,211,189" case cStyle = "H" c_Border = "196,205,179,179,218,191,212,190" case cStyle = "I" c_Border = "205,205,179,179,213,184,212,190" case cStyle = "J" c_Border = "196,196,186,186,214,183,211,189" case cStyle = "K" c_Border = "196,205,179,186,218,183,212,188" case cStyle = "L" c_Border = "196,205,186,179,214,191,200,190" case cStyle = "M" c_Border = "205,196,186,179,201,184,211,217" case cStyle = "N" c_Border = "205,196,179,186,213,187,192,189" case cStyle = "O" c_Border = "205,205,179,186,213,187,212,188" case cStyle = "P" c_Border = "205,205,186,179,201,184,200,190" case cStyle = "Q" c_Border = "196,196,186,179,214,191,211,217" case cStyle = "R" c_Border = "196,196,179,186,218,183,192,189" case cStyle = "S" c_Border = "223,220,222,221,222,221,222,221" endcase set border to &c_Border RETURN cReturn *-- EoF: NewBorder FUNCTION VidRow *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 01/28/1993 *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635) *-- to return the ABSOLUTE position of the current ROW on the *-- screen, despite any active windows, etc. *-- This is based on original routines by David Frankenbach, *-- but includes the load/release in one routine, rather *-- than requiring three functions to perform this ... *-- *************************** *-- ** REQUIRES VDCURSOR.BIN ** *-- *************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: VDCURSOR.BIN *-- Called by...: Any *-- Usage.......: VidRow() *-- Example.....: ?VidRow() *-- Returns.....: Numeric ROW position for current row on screen *-- Parameters..: None *------------------------------------------------------------------------------- private cX cX = space(2) && define argument memvar load vdcursor && load the .BIN file call vdcursor with cX && call it with the memvar release module vdcursor && release from memory RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position *-- EoF: VidRow() FUNCTION VidCol *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 01/28/1993 *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635) *-- to return the ABSOLUTE position of the current COLUMN on the *-- screen, despite any active windows, etc. *-- This is based on original routines by David Frankenbach, *-- but includes the load/release in one routine, rather *-- than requiring three functions to perform this ... *-- *************************** *-- ** REQUIRES VDCURSOR.BIN ** *-- *************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: VDCURSOR.BIN *-- Called by...: Any *-- Usage.......: VidCol() *-- Example.....: ?VidCol() *-- Returns.....: Numeric COLUMN position for current Col on screen *-- Parameters..: None *------------------------------------------------------------------------------- private cX cX = space(2) && define argument memvar load vdcursor && load the .BIN file call vdcursor with cX && call it with the memvar release module vdcursor && release from memory RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position *-- EoF: VidCol() FUNCTION PwdMask *------------------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer *-- Date........: 01/29/1993 *-- Notes.......: Designed to display a mask on the screen when a user is *-- entering a password, rather than a blank surface. Should *-- handle backspaces to delete ... ASSUMES <cField> is a *-- memvar. *-- *************************** *-- ** REQUIRES VDCURSOR.BIN ** *-- *************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: VidRow() Function in SCREEN.PRG *-- VidCol() Function in SCREEN.PRG *-- Called by...: Any *-- Usage.......: PwdMask("<cField>"[,<nMaskChar>]) *-- Example.....: @5,10 get password when PwdMask("Password"); *-- valid required .not. isblank(password); *-- error chr(7)+"Password cannot be blank) *-- Returns.....: .T., and field will have password placed in it when done. *-- Parameters..: cField = name of the field *-- nMaskChar = ASCII code for mask character. OPTIONAL parameter. *-- if not provided, will use asterisk. Suggested *-- characters include: 176,177,178,219,248,249,254 *-- ░ ▒ ▓ █ ° ∙ ■ *------------------------------------------------------------------------------- parameters cField, nMaskChar private nLength, nChar, nX *-- deal with mask character if type("NMASKCHAR") = "L" nMaskChar = 42 && * endif lCursor = set("CURSOR") = "ON" set cursor off && rather than have the cursor in the way ... nLength = len(&cField.) && get length of current field nChar = 0 && input character nRow = vidrow() && get absolute cursor location nCol = vidcol() && ditto cTemp = "" && initialize temp memvar do while len(cTemp) < nLength .and. nChar # 13 && loop until we hit end of field && or user presses <Enter> nChar = inkey(0) && wait for user to enter something do case case nChar = 127 && <BackSpace> if isblank(cTemp) && if empty, don't delete anything ?? chr(7) && instead, BEEP else cTemp = left(cTemp,len(cTemp)-1) && backup one endif case (nChar => 65 .and. nChar <= 90) .or.; (nChar => 97 .and. nChar <= 122) && alphabetic input only cTemp = cTemp + chr(nChar) && add character case nChar = 13 && <Enter> exit otherwise ?? chr(7) && otherwise, BEEP loop endcase *-- create the current "mask", padding with spaces ... cMask = replicate(chr(nMaskChar),len(cTemp)) + space(nLength-len(cTemp)) *-- display it in same color as the current "GET" @nRow,nCol get cMask clear gets *-- put password into current memvar store cTemp to &cField. enddo *-- turn cursor on if it was prior to this routine if lCursor set cursor on endif keyboard chr(13) && send a final <Enter> to exit this GET RETURN .T. *-- EoF: PwdMask() *------------------------------------------------------------------------------- *-- EoP: SCREEN.PRG *-------------------------------------------------------------------------------